home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BBS Toolkit
/
BBS Toolkit.iso
/
gt_power
/
escrub.zip
/
ESCRUB.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1989-12-01
|
15KB
|
528 lines
{$C-,V-,K-,R-,U-}
{$G512,P512,D-}
(****************************************************************************)
(* *)
(* P & M Software Company *)
(* 3104 E. Camelback Rd. #503 *)
(* Phoenix, Arizona 85016 *)
(* *)
(* November 15, 1989 *)
(* *)
(****************************************************************************)
(* *)
(* USES MAX HEAP OF $2000 *)
(* *)
(****************************************************************************)
PROGRAM
escrub;
TYPE
KEYTYPE = STRING[7];
CHARACTERS = STRING[255];
STRING80 = STRING[80];
STRING20 = STRING[20];
BYTEptr = ^BYTE;
double = ARRAY[1..4] OF BYTE;
ParmBlk = RECORD
SegAds : INTEGER;
CmdPtr : BYTEptr;
Fcb1Ptr : BYTEptr;
Fcb2Ptr : BYTEptr
END;
registerset = RECORD
AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : INTEGER;
END;
VAR
inpath : CHARACTERS;
infile_name : CHARACTERS;
file_mask : STRING80;
file_name : STRING20;
gerr : INTEGER;
outfile_name : CHARACTERS;
infile : text[$2000];
outfile : text[$2000];
tempfile : text[$2000];
infile_rec : CHARACTERS;
line_count : INTEGER;
regs : registerset;
gmask : ARRAY[1..64] OF CHAR;
dtaseg, dtaofs : INTEGER;
dta : RECORD
dta_dos : ARRAY[1..21] OF BYTE;
dta_attrib : BYTE;
dta_time : INTEGER;
dta_date : INTEGER;
dta_size : double;
dta_fname : ARRAY[1..13] OF CHAR;
dta_fill : ARRAY[1..32] OF CHAR;
END;
Fcb1 : ARRAY[0..63] OF CHAR;
Fcb2 : ARRAY[0..63] OF CHAR;
PathZ : ARRAY[0..80] OF CHAR;
CmdLineZ : ARRAY[0..127] OF CHAR;
BlockValue : ParmBlk;
netseq : ARRAY[1..999] OF INTEGER;
PROCEDURE
move_dta(VAR error : INTEGER);
BEGIN
WITH regs DO BEGIN
AX := $1A00;
DS := seg(dta);
DX := ofs(dta);
msdos(regs);
error := lo(AX);
END;
END;
PROCEDURE
restore_dta(VAR error : INTEGER);
BEGIN
WITH regs DO BEGIN
AX := $1A00;
DS := dtaseg;
DX := dtaofs;
msdos(regs);
error := lo(AX);
END;
END;
PROCEDURE
save_dta(VAR error : INTEGER);
BEGIN
WITH regs DO BEGIN
AX := $2F00;
msdos(regs);
dtaseg := ES;
dtaofs := BX;
error := lo(AX);
END;
END;
PROCEDURE
getfirst( buffer : STRING80;
VAR namr : STRING20;
VAR error : INTEGER );
VAR
i : INTEGER;
BEGIN
FOR i:=1 TO 64 DO
gmask[i] := #00;
save_dta(error);
IF (error <> 0) THEN BEGIN
WriteLn('Unable to get current DTA address.');
flush(output);
halt(1);
END;
move_dta(error);
IF (error <> 0) THEN BEGIN
WriteLn('Cannot reset DTA address.');
flush(output);
halt(1);
END;
FOR i := 1 TO Length(buffer) DO
gmask[i] := buffer[i];
WITH regs DO BEGIN
AX := $4E00;
DS := Seg(gmask);
DX := Ofs(gmask);
CX := 0;
msdos(regs);
error:=lo(AX);
END;
IF (error = 0) THEN BEGIN
WITH dta DO BEGIN
i := 1;
REPEAT
namr[i] := dta_fname[i];
i := succ(i);
UNTIL (dta_fname[i] = #00);
namr[0] := CHR(pred(i));
END;
END
ELSE
restore_dta(i);
END;
PROCEDURE
getnext( VAR namr : STRING20;
VAR error : INTEGER );
VAR
i : INTEGER;
BEGIN
WITH regs DO BEGIN
AX := $4F00;
CX := 16;
msdos(regs);
error := lo(AX);
END;
IF (error = 0) THEN BEGIN
i := 1;
WITH dta DO BEGIN
REPEAT
namr[i] := dta_fname[i];
i := succ(i);
UNTIL (dta_fname[i] = #00);
namr[0] := CHR(pred(i));
END;
END
ELSE
restore_dta(i);
END;
FUNCTION
DOS : INTEGER;
BEGIN
regs.AX:=$3000;
msdos(regs);
DOS:=Lo(regs.AX);
END;
FUNCTION
PSPaddr : BYTEptr;
BEGIN
IF (DOS < 3) THEN
PSPaddr:=Ptr(Cseg,0)
ELSE BEGIN
WITH regs DO BEGIN
AX:=$6200;
msdos(regs);
PSPaddr:=Ptr(BX,0)
END;
END;
END;
PROCEDURE
DosPgm(VAR regis : registerset); external 'DOSPGM.COM';
PROCEDURE
ExecPgm( PathName : STRING80;
VAR CmdLine : CHARACTERS;
VAR ErrorCode : INTEGER;
VAR ReturnCode : INTEGER );
VAR
TempPtr : BYTEptr;
PSPSeg : INTEGER;
PathLen : INTEGER;
CmdLen : INTEGER;
BEGIN
TempPtr:=PSPaddr;
PSPSeg:=Seg(TempPtr^);
BlockValue.SegAds:=MemW[PSPSeg:$2C];
BlockValue.CmdPtr := Addr(CmdLine);
CmdLen := Length(CmdLine);
Move(CmdLine[1],CmdLineZ,CmdLen);
CmdLineZ[CmdLen] := #00;
CmdLen := Succ(CmdLen);
CmdLine[CmdLen] := ^M;
WITH regs DO BEGIN
AX:=$2901;
DS:=Seg(CmdLineZ);
SI:=Ofs(CmdLineZ);
ES:=Seg(Fcb1);
DI:=Ofs(Fcb1);
msdos(regs);
AX:=$2901;
ES:=Seg(Fcb2);
DI:=Ofs(Fcb2);
msdos(regs);
BlockValue.Fcb1Ptr:=Addr(Fcb1);
BlockValue.Fcb2Ptr:=Addr(Fcb2);
AX:=$4B00;
ES:=Seg(BlockValue);
BX:=Ofs(BlockValue);
PathLen:=Length(PathName);
Move(PathName[1],PathZ,PathLen);
PathZ[PathLen]:=#00;
DS:=Seg(PathZ);
DX:=Ofs(PathZ);
DosPgm(regs);
IF ((Flags AND 1) <> 0) THEN BEGIN
ErrorCode:=AX;
ReturnCode:= -1;
END
ELSE BEGIN
ErrorCode:=0;
AX:=$4D00;
msdos(regs);
ReturnCode:=(AX AND $00FF);
END;
END;
END;
FUNCTION
GetEnUtl(EnVar : CHARACTERS) : CHARACTERS;
FUNCTION
RetEnUtl(VAR EnvPos : INTEGER) : CHARACTERS;
TYPE
Environment = ARRAY[1..32767] of CHAR;
VAR
EnvPtr : ^Environment;
StrLen : INTEGER;
I : INTEGER;
Ch : CHAR;
Str : CHARACTERS;
TempPtr : BYTEptr;
BEGIN
TempPtr:=PSPaddr;
EnvPtr:=Ptr(MemW[Seg(TempPtr^):$2C],0);
StrLen:=0;
I:=EnvPos;
Ch:=EnvPtr^[I];
WHILE (Ch <> #00) DO BEGIN
StrLen:=Succ(StrLen);
Str[StrLen]:=Ch;
I:=Succ(I);
Ch:=EnvPtr^[I]
END;
Str[0]:=CHR(StrLen);
IF (StrLen <> 0) THEN
EnvPos:=Succ(I);
RetEnUtl:=Str
END;
VAR
EnvPos : INTEGER;
EnvStr : CHARACTERS;
EqualPos : INTEGER;
Found : BOOLEAN;
BEGIN
Found :=FALSE;
EnvPos:=1;
EnvStr:=RetEnUtl(EnvPos);
WHILE ((NOT Found) AND (ORD(EnvStr[0]) <> 0)) DO BEGIN
EqualPos:=Pos('=',EnvStr);
IF (EnVar = Copy(EnvStr,1,Pred(EqualPos))) THEN
Found:=TRUE
ELSE
EnvStr:=RetEnUtl(EnvPos);
END;
IF (Found) THEN
GetEnUtl:=Copy(EnvStr,Succ(EqualPos),66)
ELSE
GetEnUtl[0]:=#00;
END;
PROCEDURE
shell(p : CHARACTERS);
LABEL
Shex;
VAR
ComSpec : STRING80;
CmdLine : CHARACTERS;
ddir : STRING80;
ecode : INTEGER;
rcode : INTEGER;
BEGIN
ComSpec:=GetEnUtl('COMSPEC');
CmdLine:=' /C ' + p + ' ';
IF (Length(ComSpec) = 0) THEN
ecode:=98
ELSE
ExecPgm(ComSpec,CmdLine,ecode,rcode);
CASE ecode OF
0 : exit;
8 : WriteLn('Not enough memory to load COMMAND.COM.');
98 : WriteLn('The COMSPEC environment parameter is not set.');
ELSE
WriteLn('Cannot find COMMAND.COM.');
END;
flush(output);
halt(1);
END;
PROCEDURE
UpString(VAR s : CHARACTERS);
VAR
i : INTEGER;
BEGIN
FOR i:=1 TO Length(s) DO
s[i] := upcase(s[i]);
END;
PROCEDURE
badfilename(VAR fn : CHARACTERS);
BEGIN
writeln('ERROR: cannot open ',fn,' for input');
flush(output);
END;
FUNCTION
echolist(VAR s : CHARACTERS) : BOOLEAN;
LABEL
N1false, N1true;
VAR
k : INTEGER;
BEGIN
IF (s[1] <> 'E') THEN
goto N1false;
FOR k:=2 TO 3 DO BEGIN
IF ((s[k] < '0') OR (s[k] > '9')) THEN
goto N1false;
END;
FOR k:=5 TO 7 DO BEGIN
IF ((s[k] < '0') OR (s[k] > '9')) THEN
goto N1false;
END;
IF (s[4] <> '/') THEN
goto N1false;
CASE s[8] OF
' ' : ;
'p' : ;
'a' : ;
'g' : ;
ELSE
goto N1false;
END;
IF (s[9] <> ' ') THEN
goto N1false;
IF (s[56] <> ' ') THEN
goto N1false;
FOR k:=57 TO 59 DO BEGIN
IF ((s[k] < '0') OR (s[k] > '9')) THEN
goto N1false;
END;
FOR k:=61 TO 63 DO BEGIN
IF ((s[k] < '0') OR (s[k] > '9')) THEN
goto N1false;
END;
IF (s[60] <> '/') THEN
goto N1false;
IF (s[64] <> ' ') THEN
goto N1false;
N1true:
echolist := TRUE;
exit;
N1false:
echolist := FALSE;
END;
PROCEDURE
process_outfile(VAR s : CHARACTERS);
VAR
cnet : INTEGER;
verr : INTEGER;
k : INTEGER;
seqst : STRING[10];
BEGIN
val(copy(s,57,3),cnet,verr);
netseq[cnet] := Succ(netseq[cnet]);
str(netseq[cnet]:5,seqst);
FOR k:=1 TO 5 DO BEGIN
IF (seqst[k] = ' ') THEN
seqst[k]:='0';
END;
writeln(outfile,copy(s,1,7),' ',seqst,' ',copy(s,8,241));
line_count:=Succ(line_count);
END;
PROCEDURE
process_temp;
VAR
infilekey : KEYTYPE;
tempkey : KEYTYPE;
hold_rec : CHARACTERS;
BEGIN
assign(outfile,outfile_name);
{$I-}
rewrite(outfile);
{$I+}
IF (IOresult <> 0) THEN BEGIN
writeln('ERROR: cannot open ',outfile_name,' for output');
flush(output);
halt(1);
END;
assign(tempfile,'$$TEMP');
{$I-}
reset(tempfile);
{$I+}
tempkey := #00#00#00#00#00#00#00;
WHILE (NOT eof(tempfile)) DO BEGIN
readln(tempfile,infile_rec);
IF (tempkey[1] = #00) THEN BEGIN
hold_rec:=infile_rec;
infilekey:=copy(infile_rec,1,7);
END;
tempkey:=copy(infile_rec,1,7);
IF (tempkey <> infilekey) THEN
writeln(outfile,infilekey,copy(hold_rec,15,241));
hold_rec:=infile_rec;
infilekey:=copy(infile_rec,1,7);
END;
IF (tempkey[1] <> #00) THEN
writeln(outfile,tempkey,copy(hold_rec,15,241));
close(tempfile);
close(outfile);
END;
LABEL
S1loop;
VAR
k : INTEGER;
BEGIN
lowvideo;
writeln('ESCRUB Version 001');
writeln;
flush(output);
IF (ParamCount < 2) THEN BEGIN
writeln('ERROR: too few command line arguments');
writeln(' The correct syntax is: ESCRUB msgpath outfile');
flush(output);
halt(1);
END;
inpath := ParamStr(1) + '\GTMSGS\';
UpString(inpath);
outfile_name := ParamStr(2);
UpString(outfile_name);
assign(outfile,outfile_name);
{$I-}
rewrite(outfile);
{$I+}
IF (IOresult <> 0) THEN BEGIN
writeln('ERROR: cannot open ',outfile_name,' for output');
flush(output);
halt(1);
END;
FOR k:=1 TO 999 DO
netseq[k]:=0;
line_count:=0;
file_mask := inpath + '?????.MSG';
getfirst(file_mask,file_name,gerr);
WHILE (gerr = 0) DO BEGIN
restore_dta(gerr);
(*** PROCESS ***)
infile_name := inpath + file_name;
writeln('Processing: ',infile_name);
flush(output);
assign(infile,infile_name);
{$I-}
reset(infile);
{$I+}
IF (IOresult <> 0) THEN BEGIN
badfilename(infile_name);
goto S1loop;
END;
WHILE (NOT eof(infile)) DO BEGIN
readln(infile,infile_rec);
IF (echolist(infile_rec)) THEN
process_outfile(infile_rec);
END;
(***************)
close(infile);
S1loop:
save_dta(gerr);
move_dta(gerr);
getnext(file_name,gerr);
END;
close(outfile);
IF (line_count > 0) THEN BEGIN
shell('sort <'+outfile_name+' >$$TEMP');
process_temp;
shell('del $$TEMP');
END;
END.